;;;; standard-game.lisp

(in-package #:gamao-impl)

;;; STANDARD ACTIONS

(defclass standard-game-actions-mixin ()
  ())

(defmethod roll-dice ((game standard-game-actions-mixin) player)
  (setf (dice-rolling-p game) t)
  game)

(defmethod pick-up-dice ((game standard-game-actions-mixin) player)
  game)

(defmethod new-dice ((game standard-game-actions-mixin) die1 die2)
  (set-dice game die1 die2)
  game)

(defmethod offer-double ((game standard-game-actions-mixin) player)
  (setf (cube-offered-p game) t)
  game)

(defmethod accept-double ((game standard-game-actions-mixin) player)
  (setf (cube-value game) (* 2 (cube-value game))
        (cube-offered-p game) nil)
  game)

(defmethod reject-double ((game standard-game-actions-mixin) player)
  (setf (game-result game) :single
        (winner game) (opponent player))
  game)

;;; STANDARD GAMEPLAY

(defclass standard-gameplay-mixin ()
  ())

;; If a partial move finishes a game, there is no need to complete it.
(defmethod move-checker :after ((game standard-gameplay-mixin) player from pips)
  (let ((result (checker-position-result game (checkers game) player)))
    (when (not (null result))
      (setf (game-result game) result
            (winner game) player))))

(defmethod pick-up-dice :after ((game standard-gameplay-mixin) player)
  (set-dice game nil nil)
  (setf (current-player game) (opponent player)))

(defmethod offer-double :after ((game standard-gameplay-mixin) player)
  (setf (current-player game) (opponent player)))

(defmethod accept-double :after ((game standard-gameplay-mixin) player)
  (setf (cube-owner game) player)
  (setf (current-player game) (opponent player)))

(defmethod new-dice :after ((game standard-gameplay-mixin) die1 die2)
  (setf (dice-rolling-p game) nil)
  (when (null (current-player game))
    (cond ((> die1 die2) (setf (current-player game) :black))
          ((> die2 die1) (setf (current-player game) :white)))))

;;;; REUSE FIRST DICE

(defclass reuse-first-dice-mixin ()
  ((reuse-first-dice-first-roll? :initform t)))

(defmethod new-dice :around ((game reuse-first-dice-mixin) die1 die2)
  (let ((vals (multiple-value-list (call-next-method))))
    (with-slots (reuse-first-dice-first-roll?) game
      (if (and reuse-first-dice-first-roll?
               (not (null (current-player game))))
          (progn
            (setf reuse-first-dice-first-roll? nil
                  (dice-rolling-p game) t)
            (new-dice game (max die1 die2) (min die1 die2)))
          (values-list vals)))))

;;;; LEGALITY CHECKS

(defclass you-may-only-if-it-is-your-turn-mixin ()
  ())

;;; TODO Macros using *game-legality-checks* are similar, refactor them.

(defmacro define-you-may-only-if-it-is-your-turn-legality-checks ()
  (let ((defs (loop for (check . actions) in *game-legality-checks*
                    for args = (rest (find (first actions) *game-actions* :key #'first))
                    for specialized-args = (substitute '(game you-may-only-if-it-is-your-turn-mixin) 'game args)
                    collect `(defmethod ,check ,specialized-args
                               ,(if (member 'player args)
                                    '(if (eq (current-player game) player)
                                         (call-next-method)
                                         (values nil 'not-your-turn))
                                    '(call-next-method))))))
    `(progn
       ,@defs
       ',(mapcar #'first *game-legality-checks*))))

(define-you-may-only-if-it-is-your-turn-legality-checks)

(defclass nothing-is-permitted-when-the-game-is-over-mixin ()
  ())

(defmacro define-nothing-is-permitted-when-the-game-is-over-legality-checks ()
  (let ((defs (loop for (check . actions) in *game-legality-checks*
                    for args = (rest (find (first actions) *game-actions* :key #'first))
                    for specialized-args = (substitute '(game nothing-is-permitted-when-the-game-is-over-mixin) 'game args)
                    collect `(defmethod ,check ,specialized-args
                               (if (not (null (game-result game)))
                                   (values nil 'game-over)
                                   (call-next-method))))))
    `(progn
       ,@defs
       ',(mapcar #'first *game-legality-checks*))))

(define-nothing-is-permitted-when-the-game-is-over-legality-checks)

(defclass simple-legality-mixin ()
  ())

(defmethod may-set-dice-p ((game simple-legality-mixin) die1 die2)
  (or (null (current-player game))
      (dice-rolling-p game)))

(defmethod may-offer-double-p ((game simple-legality-mixin) player)
  (and (not (null (cube-value game)))
       (not (dice-rolling-p game))
       (null (die1 game))
       (not (eq (cube-owner game) (opponent player)))))

(defmethod may-roll-dice-p ((game simple-legality-mixin) player)
  (and (null (die1 game))
       (not (dice-rolling-p game))
       (not (cube-offered-p game))))

(defmethod may-accept-reject-double-p ((game simple-legality-mixin) player)
  (cube-offered-p game))

(defclass standard-legality-mixin (you-may-only-if-it-is-your-turn-mixin
                                   nothing-is-permitted-when-the-game-is-over-mixin
                                   simple-legality-mixin)
  ())

;;; ABIDE BY THE RULES

(defclass rule-abiding-game-mixin ()
  ())

(defmacro define-rule-abiding-actions ()
  (let ((defs (loop with game-var = 'game
                    with mixin-name = 'rule-abiding-game-mixin
                    for action in *game-actions*
                    for action-name = (first action)
                    for action-args = (rest action)
                    for specialized-args = (subst `(,game-var ,mixin-name) game-var action-args)
                    for legality-check = (first (find action-name *game-legality-checks* :key #'rest :test #'member))
                    when legality-check
                    collect `(defmethod ,action-name :around ,specialized-args
                               (multiple-value-bind (valid? reason) (,legality-check ,@action-args)
                                 (if valid?
                                     (call-next-method)
                                     (values valid? reason)))))))
    `(progn
       ,@defs
       ',(mapcar #'first *game-actions*))))

(define-rule-abiding-actions)
